home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / C / Applications / MacPerl 5.0.3 / MacPerl Source ƒ / Perl5 / ext / DB_File / DB_File.xs < prev    next >
Encoding:
Text File  |  1995-02-02  |  18.6 KB  |  946 lines  |  [TEXT/MPS ]
  1. /* 
  2.  
  3.  DB_File.xs -- Perl 5 interface to Berkeley DB 
  4.  
  5.  written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
  6.  last modified 23rd June 1994
  7.  version 0.1
  8.  
  9.  All comments/suggestions/problems are welcome
  10.  
  11. */
  12.  
  13. #include "EXTERN.h"  
  14. #include "perl.h"
  15. #include "XSUB.h"
  16.  
  17. #include <db.h>
  18.  
  19. #include <fcntl.h> 
  20.  
  21. #ifndef DBXS_HASH_TYPE
  22. #define DBXS_HASH_TYPE u_int
  23. #endif
  24.  
  25. #ifndef DBXS_PREFIX_TYPE
  26. #define DBXS_PREFIX_TYPE size_t
  27. #endif
  28.  
  29. typedef DB * DB_File;
  30. typedef DBT DBTKEY ;
  31.  
  32. union INFO {
  33.         HASHINFO     hash ;
  34.         RECNOINFO     recno ;
  35.         BTREEINFO     btree ;
  36.       } ;
  37.  
  38. typedef struct {
  39.         SV *    sub ;
  40.     } CallBackInfo ;
  41.  
  42.  
  43. /* #define TRACE  */
  44.  
  45. #define db_DESTROY(db)                  (db->close)(db)
  46. #define db_DELETE(db, key, flags)       (db->del)(db, &key, flags)
  47. #define db_STORE(db, key, value, flags) (db->put)(db, &key, &value, flags)
  48. #define db_FETCH(db, key, flags)        (db->get)(db, &key, &value, flags)
  49.  
  50. #define db_close(db)            (db->close)(db)
  51. #define db_del(db, key, flags)          (db->del)(db, &key, flags)
  52. #define db_fd(db)                       (db->fd)(db) 
  53. #define db_put(db, key, value, flags)   (db->put)(db, &key, &value, flags)
  54. #define db_get(db, key, value, flags)   (db->get)(db, &key, &value, flags)
  55. #define db_seq(db, key, value, flags)   (db->seq)(db, &key, &value, flags)
  56. #define db_sync(db, flags)              (db->sync)(db, flags)
  57.  
  58.  
  59. #define OutputValue(arg, name)  \
  60.     { if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; }
  61.  
  62. #define OutputKey(arg, name)                     \
  63.     { if (RETVAL == 0) \
  64.       {                             \
  65.         if (db->close != DB_recno_close)         \
  66.             sv_setpvn(arg, name.data, name.size);     \
  67.         else                         \
  68.             sv_setiv(arg, (I32)*(I32*)name.data - 1);     \
  69.       }                             \
  70.     }
  71.  
  72. /* Internal Global Data */
  73.  
  74. static recno_t Value ;
  75. static int (*DB_recno_close)() = NULL ;
  76.  
  77. static CallBackInfo hash_callback     = { 0 } ;
  78. static CallBackInfo compare_callback     = { 0 } ;
  79. static CallBackInfo prefix_callback     = { 0 } ;
  80.  
  81.  
  82. static int
  83. btree_compare(key1, key2)
  84. const DBT * key1 ;
  85. const DBT * key2 ;
  86. {
  87.     dSP ;
  88.     void * data1, * data2 ;
  89.     int retval ;
  90.     int count ;
  91.     
  92.     data1 = key1->data ;
  93.     data2 = key2->data ;
  94.  
  95.     /* As newSVpv will assume that the data pointer is a null terminated C 
  96.        string if the size parameter is 0, make sure that data points to an 
  97.        empty string if the length is 0
  98.     */
  99.     if (key1->size == 0)
  100.         data1 = "" ; 
  101.     if (key2->size == 0)
  102.         data2 = "" ;
  103.  
  104.     ENTER ;
  105.     SAVETMPS;
  106.  
  107.     PUSHMARK(sp) ;
  108.     EXTEND(sp,2) ;
  109.     PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
  110.     PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
  111.     PUTBACK ;
  112.  
  113.     count = perl_call_sv(compare_callback.sub, G_SCALAR); 
  114.  
  115.     SPAGAIN ;
  116.  
  117.     if (count != 1)
  118.         croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;
  119.  
  120.     retval = POPi ;
  121.  
  122.     PUTBACK ;
  123.     FREETMPS ;
  124.     LEAVE ;
  125.     return (retval) ;
  126.  
  127. }
  128.  
  129. static DBXS_PREFIX_TYPE
  130. btree_prefix(key1, key2)
  131. const DBT * key1 ;
  132. const DBT * key2 ;
  133. {
  134.     dSP ;
  135.     void * data1, * data2 ;
  136.     int retval ;
  137.     int count ;
  138.     
  139.     data1 = key1->data ;
  140.     data2 = key2->data ;
  141.  
  142.     /* As newSVpv will assume that the data pointer is a null terminated C 
  143.        string if the size parameter is 0, make sure that data points to an 
  144.        empty string if the length is 0
  145.     */
  146.     if (key1->size == 0)
  147.         data1 = "" ;
  148.     if (key2->size == 0)
  149.         data2 = "" ;
  150.  
  151.     ENTER ;
  152.     SAVETMPS;
  153.  
  154.     PUSHMARK(sp) ;
  155.     EXTEND(sp,2) ;
  156.     PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
  157.     PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
  158.     PUTBACK ;
  159.  
  160.     count = perl_call_sv(prefix_callback.sub, G_SCALAR); 
  161.  
  162.     SPAGAIN ;
  163.  
  164.     if (count != 1)
  165.         croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
  166.  
  167.     retval = POPi ;
  168.  
  169.     PUTBACK ;
  170.     FREETMPS ;
  171.     LEAVE ;
  172.  
  173.     return (retval) ;
  174. }
  175.  
  176. static DBXS_HASH_TYPE
  177. hash_cb(data, size)
  178. const void * data ;
  179. size_t size ;
  180. {
  181.     dSP ;
  182.     int retval ;
  183.     int count ;
  184.  
  185.     if (size == 0)
  186.         data = "" ;
  187.  
  188.     PUSHMARK(sp) ;
  189.     XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
  190.     PUTBACK ;
  191.  
  192.     count = perl_call_sv(hash_callback.sub, G_SCALAR); 
  193.  
  194.     SPAGAIN ;
  195.  
  196.     if (count != 1)
  197.         croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;
  198.  
  199.     retval = POPi ;
  200.  
  201.     PUTBACK ;
  202.     FREETMPS ;
  203.     LEAVE ;
  204.  
  205.     return (retval) ;
  206. }
  207.  
  208.  
  209. #ifdef TRACE
  210.  
  211. static void
  212. PrintHash(hash)
  213. HASHINFO hash ;
  214. {
  215.     printf ("HASH Info\n") ;
  216.     printf ("  hash      = %s\n", (hash.hash != NULL ? "redefined" : "default")) ;
  217.     printf ("  bsize     = %d\n", hash.bsize) ;
  218.     printf ("  ffactor   = %d\n", hash.ffactor) ;
  219.     printf ("  nelem     = %d\n", hash.nelem) ;
  220.     printf ("  cachesize = %d\n", hash.cachesize) ;
  221.     printf ("  lorder    = %d\n", hash.lorder) ;
  222.  
  223. }
  224.  
  225. static void
  226. PrintRecno(recno)
  227. RECNOINFO recno ;
  228. {
  229.     printf ("RECNO Info\n") ;
  230.     printf ("  flags     = %d\n", recno.flags) ;
  231.     printf ("  cachesize = %d\n", recno.cachesize) ;
  232.     printf ("  psize     = %d\n", recno.psize) ;
  233.     printf ("  lorder    = %d\n", recno.lorder) ;
  234.     printf ("  reclen    = %d\n", recno.reclen) ;
  235.     printf ("  bval      = %d\n", recno.bval) ;
  236.     printf ("  bfname    = %s\n", recno.bfname) ;
  237. }
  238.  
  239. PrintBtree(btree)
  240. BTREEINFO btree ;
  241. {
  242.     printf ("BTREE Info\n") ;
  243.     printf ("  compare    = %s\n", (btree.compare ? "redefined" : "default")) ;
  244.     printf ("  prefix     = %s\n", (btree.prefix ? "redefined" : "default")) ;
  245.     printf ("  flags      = %d\n", btree.flags) ;
  246.     printf ("  cachesize  = %d\n", btree.cachesize) ;
  247.     printf ("  psize      = %d\n", btree.psize) ;
  248.     printf ("  maxkeypage = %d\n", btree.maxkeypage) ;
  249.     printf ("  minkeypage = %d\n", btree.minkeypage) ;
  250.     printf ("  lorder     = %d\n", btree.lorder) ;
  251. }
  252.  
  253. #else
  254.  
  255. #define PrintRecno(recno)
  256. #define PrintHash(hash)
  257. #define PrintBtree(btree)
  258.  
  259. #endif /* TRACE */
  260.  
  261.  
  262. static I32
  263. GetArrayLength(db)
  264. DB_File db ;
  265. {
  266.     DBT        key ;
  267.     DBT        value ;
  268.     int        RETVAL ;
  269.  
  270.     RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
  271.     if (RETVAL == 0)
  272.         RETVAL = *(I32 *)key.data ;
  273.     else if (RETVAL == 1) /* No key means empty file */
  274.         RETVAL = 0 ;
  275.  
  276.     return (RETVAL) ;
  277. }
  278.  
  279. static DB_File
  280. ParseOpenInfo(name, flags, mode, sv, string)
  281. char * name ;
  282. int    flags ;
  283. int    mode ;
  284. SV *   sv ;
  285. char * string ;
  286. {
  287.     SV **    svp;
  288.     HV *    action ;
  289.     union INFO    info ;
  290.     DB_File    RETVAL ;
  291.     void *    openinfo = NULL ;
  292.     DBTYPE    type = DB_HASH ;
  293.  
  294.  
  295.     if (sv)
  296.     {
  297.         if (! SvROK(sv) )
  298.             croak ("type parameter is not a reference") ;
  299.  
  300.         action = (HV*)SvRV(sv);
  301.         if (sv_isa(sv, "DB_File::HASHINFO"))
  302.         {
  303.             type = DB_HASH ;
  304.             openinfo = (void*)&info ;
  305.   
  306.             svp = hv_fetch(action, "hash", 4, FALSE); 
  307.  
  308.             if (svp && SvOK(*svp))
  309.             {
  310.                 info.hash.hash = hash_cb ;
  311.         hash_callback.sub = *svp ;
  312.             }
  313.             else
  314.             info.hash.hash = NULL ;
  315.  
  316.            svp = hv_fetch(action, "bsize", 5, FALSE);
  317.            info.hash.bsize = svp ? SvIV(*svp) : 0;
  318.            
  319.            svp = hv_fetch(action, "ffactor", 7, FALSE);
  320.            info.hash.ffactor = svp ? SvIV(*svp) : 0;
  321.          
  322.            svp = hv_fetch(action, "nelem", 5, FALSE);
  323.            info.hash.nelem = svp ? SvIV(*svp) : 0;
  324.          
  325.            svp = hv_fetch(action, "cachesize", 9, FALSE);
  326.            info.hash.cachesize = svp ? SvIV(*svp) : 0;
  327.          
  328.            svp = hv_fetch(action, "lorder", 6, FALSE);
  329.            info.hash.lorder = svp ? SvIV(*svp) : 0;
  330.  
  331.            PrintHash(info) ; 
  332.         }
  333.         else if (sv_isa(sv, "DB_File::BTREEINFO"))
  334.         {
  335.             type = DB_BTREE ;
  336.             openinfo = (void*)&info ;
  337.    
  338.             svp = hv_fetch(action, "compare", 7, FALSE);
  339.             if (svp && SvOK(*svp))
  340.             {
  341.                 info.btree.compare = btree_compare ;
  342.                 compare_callback.sub = *svp ;
  343.             }
  344.             else
  345.                 info.btree.compare = NULL ;
  346.  
  347.             svp = hv_fetch(action, "prefix", 6, FALSE);
  348.             if (svp && SvOK(*svp))
  349.             {
  350.                 info.btree.prefix = btree_prefix ;
  351.                 prefix_callback.sub = *svp ;
  352.             }
  353.             else
  354.                 info.btree.prefix = NULL ;
  355.  
  356.             svp = hv_fetch(action, "flags", 5, FALSE);
  357.             info.btree.flags = svp ? SvIV(*svp) : 0;
  358.    
  359.             svp = hv_fetch(action, "cachesize", 9, FALSE);
  360.             info.btree.cachesize = svp ? SvIV(*svp) : 0;
  361.          
  362.             svp = hv_fetch(action, "minkeypage", 10, FALSE);
  363.             info.btree.minkeypage = svp ? SvIV(*svp) : 0;
  364.         
  365.             svp = hv_fetch(action, "maxkeypage", 10, FALSE);
  366.             info.btree.maxkeypage = svp ? SvIV(*svp) : 0;
  367.  
  368.             svp = hv_fetch(action, "psize", 5, FALSE);
  369.             info.btree.psize = svp ? SvIV(*svp) : 0;
  370.          
  371.             svp = hv_fetch(action, "lorder", 6, FALSE);
  372.             info.btree.lorder = svp ? SvIV(*svp) : 0;
  373.  
  374.             PrintBtree(info) ;
  375.          
  376.         }
  377.         else if (sv_isa(sv, "DB_File::RECNOINFO"))
  378.         {
  379.             type = DB_RECNO ;
  380.             openinfo = (void *)&info ;
  381.  
  382.             svp = hv_fetch(action, "flags", 5, FALSE);
  383.             info.recno.flags = (u_long) svp ? SvIV(*svp) : 0;
  384.          
  385.             svp = hv_fetch(action, "cachesize", 9, FALSE);
  386.             info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
  387.          
  388.             svp = hv_fetch(action, "psize", 5, FALSE);
  389.             info.recno.psize = (int) svp ? SvIV(*svp) : 0;
  390.          
  391.             svp = hv_fetch(action, "lorder", 6, FALSE);
  392.             info.recno.lorder = (int) svp ? SvIV(*svp) : 0;
  393.          
  394.             svp = hv_fetch(action, "reclen", 6, FALSE);
  395.             info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
  396.          
  397.         svp = hv_fetch(action, "bval", 4, FALSE);
  398.             if (svp && SvOK(*svp))
  399.             {
  400.                 if (SvPOK(*svp))
  401.             info.recno.bval = (u_char)*SvPV(*svp, na) ;
  402.         else
  403.             info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
  404.             }
  405.             else
  406.          {
  407.         if (info.recno.flags & R_FIXEDLEN)
  408.                     info.recno.bval = (u_char) ' ' ;
  409.         else
  410.                     info.recno.bval = (u_char) '\n' ;
  411.         }
  412.          
  413.             svp = hv_fetch(action, "bfname", 6, FALSE); 
  414.             info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0;
  415.  
  416.             PrintRecno(info) ;
  417.         }
  418.         else
  419.             croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
  420.     }
  421.  
  422.  
  423.     RETVAL = dbopen(name, flags, mode, type, openinfo) ; 
  424.  
  425.     if (RETVAL == 0)
  426.         croak("DB_File::%s failed, reason: %s", string, Strerror(errno)) ;
  427.  
  428.     /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE
  429.                so remember a DB_RECNO by saving the address
  430.                of one of it's internal routines
  431.     */
  432.     if (type == DB_RECNO)
  433.         DB_recno_close = RETVAL->close ;
  434.  
  435.  
  436.     return (RETVAL) ;
  437. }
  438.  
  439.  
  440. static int
  441. not_here(s)
  442. char *s;
  443. {
  444.     croak("DB_File::%s not implemented on this architecture", s);
  445.     return -1;
  446. }
  447.  
  448. static double 
  449. constant(name, arg)
  450. char *name;
  451. int arg;
  452. {
  453.     errno = 0;
  454.     switch (*name) {
  455.     case 'A':
  456.     break;
  457.     case 'B':
  458.     if (strEQ(name, "BTREEMAGIC"))
  459. #ifdef BTREEMAGIC
  460.         return BTREEMAGIC;
  461. #else
  462.         goto not_there;
  463. #endif
  464.     if (strEQ(name, "BTREEVERSION"))
  465. #ifdef BTREEVERSION
  466.         return BTREEVERSION;
  467. #else
  468.         goto not_there;
  469. #endif
  470.     break;
  471.     case 'C':
  472.     break;
  473.     case 'D':
  474.     if (strEQ(name, "DB_LOCK"))
  475. #ifdef DB_LOCK
  476.         return DB_LOCK;
  477. #else
  478.         goto not_there;
  479. #endif
  480.     if (strEQ(name, "DB_SHMEM"))
  481. #ifdef DB_SHMEM
  482.         return DB_SHMEM;
  483. #else
  484.         goto not_there;
  485. #endif
  486.     if (strEQ(name, "DB_TXN"))
  487. #ifdef DB_TXN
  488.         return (U32)DB_TXN;
  489. #else
  490.         goto not_there;
  491. #endif
  492.     break;
  493.     case 'E':
  494.     break;
  495.     case 'F':
  496.     break;
  497.     case 'G':
  498.     break;
  499.     case 'H':
  500.     if (strEQ(name, "HASHMAGIC"))
  501. #ifdef HASHMAGIC
  502.         return HASHMAGIC;
  503. #else
  504.         goto not_there;
  505. #endif
  506.     if (strEQ(name, "HASHVERSION"))
  507. #ifdef HASHVERSION
  508.         return HASHVERSION;
  509. #else
  510.         goto not_there;
  511. #endif
  512.     break;
  513.     case 'I':
  514.     break;
  515.     case 'J':
  516.     break;
  517.     case 'K':
  518.     break;
  519.     case 'L':
  520.     break;
  521.     case 'M':
  522.     if (strEQ(name, "MAX_PAGE_NUMBER"))
  523. #ifdef MAX_PAGE_NUMBER
  524.         return (U32)MAX_PAGE_NUMBER;
  525. #else
  526.         goto not_there;
  527. #endif
  528.     if (strEQ(name, "MAX_PAGE_OFFSET"))
  529. #ifdef MAX_PAGE_OFFSET
  530.         return MAX_PAGE_OFFSET;
  531. #else
  532.         goto not_there;
  533. #endif
  534.     if (strEQ(name, "MAX_REC_NUMBER"))
  535. #ifdef MAX_REC_NUMBER
  536.         return (U32)MAX_REC_NUMBER;
  537. #else
  538.         goto not_there;
  539. #endif
  540.     break;
  541.     case 'N':
  542.     break;
  543.     case 'O':
  544.     break;
  545.     case 'P':
  546.     break;
  547.     case 'Q':
  548.     break;
  549.     case 'R':
  550.     if (strEQ(name, "RET_ERROR"))
  551. #ifdef RET_ERROR
  552.         return RET_ERROR;
  553. #else
  554.         goto not_there;
  555. #endif
  556.     if (strEQ(name, "RET_SPECIAL"))
  557. #ifdef RET_SPECIAL
  558.         return RET_SPECIAL;
  559. #else
  560.         goto not_there;
  561. #endif
  562.     if (strEQ(name, "RET_SUCCESS"))
  563. #ifdef RET_SUCCESS
  564.         return RET_SUCCESS;
  565. #else
  566.         goto not_there;
  567. #endif
  568.     if (strEQ(name, "R_CURSOR"))
  569. #ifdef R_CURSOR
  570.         return R_CURSOR;
  571. #else
  572.         goto not_there;
  573. #endif
  574.     if (strEQ(name, "R_DUP"))
  575. #ifdef R_DUP
  576.         return R_DUP;
  577. #else
  578.         goto not_there;
  579. #endif
  580.     if (strEQ(name, "R_FIRST"))
  581. #ifdef R_FIRST
  582.         return R_FIRST;
  583. #else
  584.         goto not_there;
  585. #endif
  586.     if (strEQ(name, "R_FIXEDLEN"))
  587. #ifdef R_FIXEDLEN
  588.         return R_FIXEDLEN;
  589. #else
  590.         goto not_there;
  591. #endif
  592.     if (strEQ(name, "R_IAFTER"))
  593. #ifdef R_IAFTER
  594.         return R_IAFTER;
  595. #else
  596.         goto not_there;
  597. #endif
  598.     if (strEQ(name, "R_IBEFORE"))
  599. #ifdef R_IBEFORE
  600.         return R_IBEFORE;
  601. #else
  602.         goto not_there;
  603. #endif
  604.     if (strEQ(name, "R_LAST"))
  605. #ifdef R_LAST
  606.         return R_LAST;
  607. #else
  608.         goto not_there;
  609. #endif
  610.     if (strEQ(name, "R_NEXT"))
  611. #ifdef R_NEXT
  612.         return R_NEXT;
  613. #else
  614.         goto not_there;
  615. #endif
  616.     if (strEQ(name, "R_NOKEY"))
  617. #ifdef R_NOKEY
  618.         return R_NOKEY;
  619. #else
  620.         goto not_there;
  621. #endif
  622.     if (strEQ(name, "R_NOOVERWRITE"))
  623. #ifdef R_NOOVERWRITE
  624.         return R_NOOVERWRITE;
  625. #else
  626.         goto not_there;
  627. #endif
  628.     if (strEQ(name, "R_PREV"))
  629. #ifdef R_PREV
  630.         return R_PREV;
  631. #else
  632.         goto not_there;
  633. #endif
  634.     if (strEQ(name, "R_RECNOSYNC"))
  635. #ifdef R_RECNOSYNC
  636.         return R_RECNOSYNC;
  637. #else
  638.         goto not_there;
  639. #endif
  640.     if (strEQ(name, "R_SETCURSOR"))
  641. #ifdef R_SETCURSOR
  642.         return R_SETCURSOR;
  643. #else
  644.         goto not_there;
  645. #endif
  646.     if (strEQ(name, "R_SNAPSHOT"))
  647. #ifdef R_SNAPSHOT
  648.         return R_SNAPSHOT;
  649. #else
  650.         goto not_there;
  651. #endif
  652.     break;
  653.     case 'S':
  654.     break;
  655.     case 'T':
  656.     break;
  657.     case 'U':
  658.     break;
  659.     case 'V':
  660.     break;
  661.     case 'W':
  662.     break;
  663.     case 'X':
  664.     break;
  665.     case 'Y':
  666.     break;
  667.     case 'Z':
  668.     break;
  669.     case '_':
  670.     if (strEQ(name, "__R_UNUSED"))
  671. #ifdef __R_UNUSED
  672.         return __R_UNUSED;
  673. #else
  674.         goto not_there;
  675. #endif
  676.     break;
  677.     }
  678.     errno = EINVAL;
  679.     return 0;
  680.  
  681. not_there:
  682.     errno = ENOENT;
  683.     return 0;
  684. }
  685.  
  686. MODULE = DB_File    PACKAGE = DB_File    PREFIX = db_
  687.  
  688. double
  689. constant(name,arg)
  690.     char *        name
  691.     int        arg
  692.  
  693.  
  694. DB_File
  695. db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH)
  696.     char *        dbtype
  697.     int        flags
  698.     int        mode
  699.     CODE:
  700.     {
  701.         char *    name = (char *) NULL ; 
  702.         SV *    sv = (SV *) NULL ; 
  703.  
  704.         if (items >= 2 && SvOK(ST(1))) 
  705.             name = (char*) SvPV(ST(1), na) ; 
  706.  
  707.             if (items == 5)
  708.             sv = ST(4) ;
  709.  
  710.         RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
  711.     }
  712.     OUTPUT:    
  713.         RETVAL
  714.  
  715. BOOT:
  716.     newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);
  717.  
  718. int
  719. db_DESTROY(db)
  720.     DB_File        db
  721.  
  722.  
  723. int
  724. db_DELETE(db, key, flags=0)
  725.     DB_File        db
  726.     DBTKEY        key
  727.     u_int        flags
  728.  
  729. int
  730. db_FETCH(db, key, flags=0)
  731.     DB_File        db
  732.     DBTKEY        key
  733.     u_int        flags
  734.     CODE:
  735.     {
  736.         DBT        value  ;
  737.  
  738.         RETVAL = (db->get)(db, &key, &value, flags) ;
  739.         ST(0) = sv_newmortal();
  740.         if (RETVAL == 0)
  741.             sv_setpvn(ST(0), value.data, value.size);
  742.     }
  743.  
  744. int
  745. db_STORE(db, key, value, flags=0)
  746.     DB_File        db
  747.     DBTKEY        key
  748.     DBT        value
  749.     u_int        flags
  750.  
  751.  
  752. int
  753. db_FIRSTKEY(db)
  754.     DB_File        db
  755.     CODE:
  756.     {
  757.         DBTKEY        key ;
  758.         DBT        value ;
  759.  
  760.         RETVAL = (db->seq)(db, &key, &value, R_FIRST) ;
  761.         ST(0) = sv_newmortal();
  762.         if (RETVAL == 0)
  763.         {
  764.             if (db->type != DB_RECNO)
  765.                 sv_setpvn(ST(0), key.data, key.size);
  766.             else
  767.                 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
  768.         }
  769.     }
  770.  
  771. int
  772. db_NEXTKEY(db, key)
  773.     DB_File        db
  774.     DBTKEY        key
  775.     CODE:
  776.     {
  777.         DBT        value ;
  778.  
  779.         RETVAL = (db->seq)(db, &key, &value, R_NEXT) ;
  780.         ST(0) = sv_newmortal();
  781.         if (RETVAL == 0)
  782.         {
  783.             if (db->type != DB_RECNO)
  784.                 sv_setpvn(ST(0), key.data, key.size);
  785.             else
  786.                 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
  787.         }
  788.     }
  789.  
  790. #
  791. # These would be nice for RECNO
  792. #
  793.  
  794. int
  795. unshift(db, ...)
  796.     DB_File        db
  797.     CODE:
  798.     {
  799.         DBTKEY    key ;
  800.         DBT        value ;
  801.         int        i ;
  802.         int        One ;
  803.  
  804.         RETVAL = -1 ;
  805.         for (i = items-1 ; i > 0 ; --i)
  806.         {
  807.             value.data = SvPV(ST(i), na) ;
  808.             value.size = na ;
  809.             One = 1 ;
  810.             key.data = &One ;
  811.             key.size = sizeof(int) ;
  812.             RETVAL = (db->put)(db, &key, &value, R_IBEFORE) ;
  813.             if (RETVAL != 0)
  814.                 break;
  815.         }
  816.     }
  817.     OUTPUT:
  818.         RETVAL
  819.  
  820. I32
  821. pop(db)
  822.     DB_File        db
  823.     CODE:
  824.     {
  825.         DBTKEY    key ;
  826.         DBT        value ;
  827.  
  828.         /* First get the final value */
  829.         RETVAL = (db->seq)(db, &key, &value, R_LAST) ;    
  830.         ST(0) = sv_newmortal();
  831.         /* Now delete it */
  832.         if (RETVAL == 0)
  833.         {
  834.             RETVAL = (db->del)(db, &key, R_CURSOR) ;
  835.             if (RETVAL == 0)
  836.                 sv_setpvn(ST(0), value.data, value.size);
  837.         }
  838.     }
  839.  
  840. I32
  841. shift(db)
  842.     DB_File        db
  843.     CODE:
  844.     {
  845.         DBTKEY    key ;
  846.         DBT        value ;
  847.  
  848.         /* get the first value */
  849.         RETVAL = (db->seq)(db, &key, &value, R_FIRST) ;    
  850.         ST(0) = sv_newmortal();
  851.         /* Now delete it */
  852.         if (RETVAL == 0)
  853.         {
  854.             RETVAL = (db->del)(db, &key, R_CURSOR) ;
  855.             if (RETVAL == 0)
  856.                 sv_setpvn(ST(0), value.data, value.size);
  857.         }
  858.     }
  859.  
  860.  
  861. I32
  862. push(db, ...)
  863.     DB_File        db
  864.     CODE:
  865.     {
  866.         DBTKEY    key ;
  867.         DBT        value ;
  868.         int        i ;
  869.  
  870.         /* Set the Cursor to the Last element */
  871.         RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
  872.         if (RETVAL == 0)
  873.         {
  874.         /* for (i = 1 ; i < items ; ++i) */
  875.         for (i = items - 1 ; i > 0 ; --i)
  876.         {
  877.             value.data = SvPV(ST(i), na) ;
  878.             value.size = na ;
  879.             RETVAL = (db->put)(db, &key, &value, R_IAFTER) ;
  880.             if (RETVAL != 0)
  881.                 break;
  882.         }
  883.         }
  884.     }
  885.     OUTPUT:
  886.         RETVAL
  887.  
  888.  
  889. I32
  890. length(db)
  891.     DB_File        db
  892.     CODE:
  893.         RETVAL = GetArrayLength(db) ;
  894.     OUTPUT:
  895.         RETVAL
  896.  
  897.  
  898. #
  899. # Now provide an interface to the rest of the DB functionality
  900. #
  901.  
  902. int
  903. db_del(db, key, flags=0)
  904.     DB_File        db
  905.     DBTKEY        key
  906.     u_int        flags
  907.  
  908.  
  909. int
  910. db_get(db, key, value, flags=0)
  911.     DB_File        db
  912.     DBTKEY        key
  913.     DBT        value
  914.     u_int        flags
  915.     OUTPUT:
  916.       value
  917.  
  918. int
  919. db_put(db, key, value, flags=0)
  920.     DB_File        db
  921.     DBTKEY        key
  922.     DBT        value
  923.     u_int        flags
  924.     OUTPUT:
  925.       key        if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
  926.  
  927. int
  928. db_fd(db)
  929.     DB_File        db
  930.  
  931. int
  932. db_sync(db, flags=0)
  933.     DB_File        db
  934.     u_int        flags
  935.  
  936.  
  937. int
  938. db_seq(db, key, value, flags)
  939.     DB_File        db
  940.     DBTKEY        key 
  941.     DBT        value
  942.     u_int        flags
  943.     OUTPUT:
  944.       key
  945.       value
  946.